perm filename MATCH.CRM[PAT,LMM] blob
sn#062958 filedate 1973-09-20 generic text, type T, neo UTF8
␈↓↓(FILECREATED "20-SEP-73 13:52:30" MATCH)
␈↓␈↓ εK MAKEPOSTPONEDREPLACE
␈↓ εK MAKE'APPLY* 'MATCHWM))
␈↓ εK (NIL EQLENGTH (LINKFNS . T]
(LISPXPRINT (QUOTE MATCHVARS)
␈↓ εK
T)
␈↓ εK␈↓↓(* TOP LEVEL)
␈↓
[RPAQQ MATCHVARS
␈↓ εK
((* TOP LEVEL)
␈↓ εK␈↓↓(DEFINEQ
␈↓
(FNS MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP 'MATCHELT
␈↓ εK
'MATCHSUBPAT)
␈↓ εK␈↓↓(MAKEMATCH
␈↓
(* Funargs for 'MATCHWM)
␈↓ εK [LAMBDA (VAR TOPPAT STARREPLACED)
(FNS MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE
␈↓ εK ('MATCHTOP VAR (PATPARSE TOPPAT])
MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH)
␈↓ εK
(* PREDICATES ON PATTERNS)
␈↓ εK␈↓↓('MATCHWM
␈↓
(FNS SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
␈↓ εK [LAMBDA (VAR PAT FN)
CANMATCHNILLIST REPLACEIN REPLACED)
␈↓ εK
(* LISP FUNCTION MANIPULATION)
␈↓ εK (* Creates an expression which will return non-NIL
(FNS EASYTORECOMPUTE FULLEXPANSION GENSYML MAKESUBST0
␈↓ εK if and only if the value of the VAR expression will
MAKESUBSTLIST MAKESUBSTLIST1 FORMEXPAND POSTPONEDREPLACE
␈↓ εK match the parsed pattern PAT, and the expression
POSTPONEDSETQ POSTPONE SUBSTVAR BOUNDVAR BINDVAR
␈↓ εK generated by applying (CAR FN) to
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP)
␈↓ εK (the expression giving What-Matched the first
(* LISP FUNCTION CONSTRUCTION)
␈↓ εK pattern element of PAT) and
(FNS 'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
␈↓ εK (CDR FN) -
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
␈↓ εK is non-nil as well. FN can hide side effects as
'LAST 'RETURN 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'FOR
␈↓ εK well)
'PROGN 'LISTP)
␈↓ εK
(* PATTERN PARSER)
␈↓ εK
(FNS PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR BI12
␈↓ εK (PROG (TEM1 TEM2 TAIL (SKIPEDLEN 0)
MAKEDEFAULT MAKE!PAT MAKESUBPAT)
␈↓ εK ZLENFLG)
(* FUNCTIONS, CALLS TO WHICH ARE GENERATED)
␈↓ εK RETRY
(FNS EQLENGTH)
␈↓ εK (COND
(* MISC)
␈↓ εK [(NULL PAT)
(FNS PATERR PATWARN CLISPLOOKUP VARCHECK TRUE)
␈↓ εK (RETURN (OR (NOT CHECKINGLENGTH)
(VARS VARDEFAULT MAXCDDDDRS POSTPONEFLG PATCHECKLENGTH
␈↓ εK ('NULL VAR]
POSTPONEFLG PATCAREVALUE CRLIST PATCHARS)
␈↓ εK [(NLISTP (CAR PAT))
(PROP MACRO EVERY)
␈↓ εK (COND
[ADDVARS (PRETTYMACROS (* X (E (TERPRI)
␈↓ εK ([NOT (FMEMB (CAR PAT)
(PRINT (QUOTE (* . X)))
␈↓ εK (QUOTE ($ --]
(TERPRI]
␈↓ εK (GO ELT))
(P (SETQ PATCHARRAY (MAKEBITTABLE PATCHARS)))
␈↓ εK (T (GO TAIL]
(BLOCKS (MATCHBLOCK MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP
␈↓ εK ((FMEMB (CAAR PAT)
'MATCHELT 'MATCHSUBPAT MAKE'SETQ
␈↓ εK (QUOTE (= == ' SUBPAT)))
MAKEPOSTPONEDSETQ MAKE'REPLACE
␈↓ εK (GO ELT))
MAKEPOSTPONEDREPLACE MAKE'APPLY*
␈↓ εK ((EQ (CAAR PAT)
MAKE'RETURN MAKE*GLITCH SKIP$I SKIP$ANY
␈↓ εK (QUOTE !))
PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
␈↓ εK (GO BANG))
CANMATCHNILLIST REPLACEIN REPLACED
␈↓ εK ((EQ (CAAR PAT)
EASYTORECOMPUTE FULLEXPANSION GENSYML
␈↓ εK (QUOTE $PACKED$))
MAKESUBST0 MAKESUBSTLIST MAKESUBSTLIST1
␈↓ εK (GO PACKED)))
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ
␈↓ εK [SETQ FN (SELECTQ (CAAR PAT)
POSTPONE SUBSTVAR BOUNDVAR BINDVAR
␈↓ εK (←(CONS (FUNCTION MAKE'SETQ)
SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH
␈↓ εK (CONS (CDAR PAT)
UNCROP 'NLEFT 'NOT 'NULL 'NOT1
␈↓ εK FN)))
'NOTLESSPLENGTH 'NTH 'OR 'PLUS 'REPLACE
␈↓ εK (<-(CONS (FUNCTION MAKEPOSTPONEDSETQ)
'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH
␈↓ εK (CONS (CDAR PAT)
'EQUAL 'LAST 'RETURN 'APPLY* 'HEADPLOOP
␈↓ εK FN)))
'LDIFF 'PROG 'FOR 'PROGN 'LISTP PATPARSE
␈↓ εK (→ (CONS (FUNCTION MAKE'REPLACE)
PATPARSE1 PATPARSEAT PATPARSEXPR BI12
␈↓ εK (CONS (CDAR PAT)
MAKEDEFAULT MAKE!PAT MAKESUBPAT PATERR
␈↓ εK FN)))
PATWARN CLISPLOOKUP VARCHECK TRUE
␈↓ εK (-> (CONS (FUNCTION MAKEPOSTPONEDREPLACE)
(ENTRIES MAKEMATCH)
␈↓ εK (CONS (CDAR PAT)
(GLOBALVARS PATCHARRAY PATCHARS
␈↓ εK FN)))
POSTPONEFLG VARDEFAULT CRLIST
␈↓ εK (@ (CONS (FUNCTION MAKE'APPLY*)
PATCHECKLENGTH MAXCDDDDRS)
␈↓ εK (CONS (CDAR PAT)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST
␈↓ εK FN)))
TOPPAT INASOME
␈↓ εK (* (CONS (FUNCTION MAKE'RETURN)
CHECKINGLENGTH WMLST
␈↓ εK FN))
LASTEFFECTCANBENIL
␈↓ εK (*GLITCH (CONS (FUNCTION MAKE*GLITCH)
POSTPONEDEFFECTS
␈↓ εK (CONS (CDAR PAT)
MUSTRETURN BINDINGS
␈↓ εK FN)))
GENSYMVARLIST SKIPEDLEN
␈↓ εK (HELP "INVALID PATTERN" (CAR PAT]
ZLENFLG SUBPRS)
␈↓ εK (FRPLACA PAT (SELECTQ (CAAR PAT)
(SPECVARS STARREPLACED)
␈↓ εK (* (CDAR PAT))
(BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH
␈↓ εK (CDDAR PAT)))
MAKE'SETQ MAKEPOSTPONEDSETQ
␈↓ εK (GO RETRY)
MAKE'REPLACE
␈↓ εK BANG[RETURN
(COND
␈↓ εK (CDR FN]
[(NULL (CDR PAT))
␈↓ εK (SETQ WMLST (CDR WMLST))
('AND (BLKAPPLY* (CAR FN)
␈↓ εK TEM1)))
VAR
␈↓ εK (HELP "INVALID PATTERN HERE:" (CADAR PAT]
(CDR FN))
␈↓ εK PACKED
(COND
␈↓ εK [RETURN (COND
[(EQ (CADAR PAT)
␈↓ εK [(NULL (CDR PAT))
(QUOTE SUBPAT))
␈↓ εK ('AND (OR (NOT CHECKINGLENGTH)
␈↓ εK ('EQLENGTH VAR (CDAR PAT)))
(* This isn't really a subpat and so don't rebind
␈↓ εK (BLKAPPLY* (CAR FN)
CHECKINGLENGTH etc as in 'MATCHSUBPAT)
␈↓ εK VAR
␈↓ εK (CDR FN]
␈↓ εK [(AND (EQ (CAR FN)
('MATCHWM VAR (CDDAR PAT)
␈↓ εK (QUOTE TRUE))
(QUOTE (TRUE]
␈↓ εK (NULLPAT? (CDR PAT)))
(T ('MATCHELT VAR (CDAR PAT]
␈↓ εK (OR (NOT CHECKINGLENGTH)
((NLISTP (CAR PAT))
␈↓ εK ('NOTLESSPLENGTH VAR (CDAR PAT]
(PATERR "INVALID !"))
␈↓ εK (T [SETQ TEM1 (SUBSTVAR ('NTH VAR (CDAR PAT]
(T
␈↓ εK ('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
(SELECTQ
␈↓ εK TEM1)
(CADAR PAT)
␈↓ εK (BLKAPPLY* (CAR FN)
[= (* !=)
␈↓ εK ('LDIFF VAR ('CDR TEM1))
('HEADPLOOP VAR (CDDAR PAT)
␈↓ εK (CDR FN))
(SETQ TEM1 (BOUNDVAR))
␈↓ εK ('MATCHWM ('CDR TEM1)
(CANMATCHNILLIST (CDR PAT))
␈↓ εK (CDR PAT)
('AND (BLKAPPLY* (CAR FN)
␈↓ εK (QUOTE (TRUE]
('LDIFF VAR TEM1)
␈↓ εK ELT [RETURN
(CDR FN))
␈↓ εK ('AND
('MATCHWM TEM1 (CDR PAT)
␈↓ εK [OR (NOT CHECKINGLENGTH)
(QUOTE (TRUE]
␈↓ εK (COND
(==(PATERR "!== in middle of pattern"))
␈↓ εK [(CANMATCHNIL (CAR PAT))
('(AND [OR (NLISTP (CDDAR PAT))
␈↓ εK (COND
(CDR (LAST (CDDAR PAT]
␈↓ εK ((NULL (CDR PAT))
(PATERR "!'atom in middle of pattern"))
␈↓ εK ('EQLENGTH VAR 1))
('MATCHWM
␈↓ εK ((NULLPAT? (CDR PAT))
VAR
␈↓ εK VAR)
(CONS
␈↓ εK (T (OR (NOT (CANMATCHNILLIST (CDR PAT)))
[CONS (QUOTE !)
␈↓ εK VAR]
(CONS (QUOTE SUBPAT)
␈↓ εK (T (COND
(MAPCAR (CDDAR PAT)
␈↓ εK ((NULL (CDR PAT))
(FUNCTION (LAMBDA (X)
␈↓ εK ('NULL ('CDR VAR)))
(CONS (QUOTE ')
␈↓ εK (T T]
X]
␈↓ εK ('MATCHELT ('CAR VAR)
(CDR PAT))
␈↓ εK (CAR PAT))
FN))
␈↓ εK (BLKAPPLY* (CAR FN)
(SUBPAT
␈↓ εK ('CAR VAR)
␈↓ εK (CDR FN))
(* USE THE *GLITCH KLUDGE TO GET THE WHATMATCHED OF
␈↓ εK (OR (NULL (CDR PAT))
THE REST OF THE THING)
␈↓ εK ('MATCHWM ('CDR VAR)
␈↓ εK (CDR PAT)
␈↓ εK (QUOTE (TRUE]
(COND
␈↓ εK TAIL[COND
[(EQ (CAR FN)
␈↓ εK [(NULL (CDR PAT)) (* Pattern ends in --)
(QUOTE TRUE))
␈↓ εK (RETURN (BLKAPPLY* (CAR FN)
('MATCHWM VAR (APPEND (CDDAR PAT)
␈↓ εK VAR
(CDR PAT))
␈↓ εK (CDR FN]
(QUOTE (TRUE]
␈↓ εK (INASOME
(T
␈↓ εK
(SETQ WMLST (CONS NIL WMLST))
␈↓ εK (* Reset INASOME to the match of this pattern, and
[SETQ TEM1
␈↓ εK then return T; thus the INASOME will get the correct
('AND
␈↓ εK thing to match, and yet *GLITCHES will work properly
('MATCHWM
␈↓ εK as well (maybe))
VAR
␈↓ εK
[APPEND
␈↓ εK
(CDDAR PAT)
␈↓ εK (COND
(LIST
␈↓ εK ((NEQ INASOME (QUOTE INASOME))
(CONS
␈↓ εK (HELP)))
(QUOTE *GLITCH)
␈↓ εK (SETQ INASOME (PROG (INASOME)
(CONS WMLST
␈↓ εK ('MATCHWM VAR PAT FN)))
(CONS (QUOTE !)
␈↓ εK (RETURN T))
(CONS (QUOTE SUBPAT)
␈↓ εK ((ARB? (CADR PAT))
(CDR PAT]
␈↓ εK
(QUOTE (TRUE)))
␈↓ εK (* Have two $'s in a row -- kludge to mean last, if
(BLKAPPLY* (CAR FN)
␈↓ εK there isn't anything after the second one)
('LDIFF VAR (CAR WMLST))
␈↓ εK
␈↓ εK INASOME)))
(GO LASTKLUDGE))
␈↓ εK (SETQ {OLD⎇ (EQ (CAR WATCHPOSTPONELST)
([AND (EQ (CAR FN)
␈↓ εK (QUOTE FOUND)))
(QUOTE TRUE))
␈↓ εK (SETQ WATCHPOSTPONELST (CDR WATCHPOSTPONELST))
(PROGN (SETQ TAIL (SKIP$I (CDR PAT)))
␈↓ εK ('FOR {OLD⎇ TEMVAR {ON⎇VAR {UNTIL⎇EXPR
(NOT (ZEROP SKIPEDLEN]
␈↓ εK {FINALLY⎇EXPR (CANMATCHNILLIST
␈↓ εK (CDR PAT]
(* Special check here, since might have
␈↓ εK ENDINFIXED
(... -- $4) or not need any 'NLEFT's)
␈↓ εK [RETURN
␈↓ εK (PROG (CHECKINGLENGTH)
␈↓ εK
(GO STARTWITH$N))
␈↓ εK (* If pat ends in (... -- & & &) then just match
([NULL (SETQ TAIL (SKIP$ANY (CDR PAT]
␈↓ εK (NLEFT var 3) against & & &;
(GO ENDINFIXED))
␈↓ εK CECHINGLENGTH will keep a (NULL
([AND (EQ (CAR FN)
␈↓ εK (CDDDR x)) check away)
(QUOTE TRUE))
␈↓ εK
(EQ TAIL (CDDR PAT))
␈↓ εK
(EQ SKIPEDLEN 1)
␈↓ εK (COND
(NULLPAT? TAIL)
␈↓ εK [(AND (REPLACED (CDR PAT))
(EQ (CAADR PAT)
␈↓ εK (EQ (CAR (SETQ TEM2 (FULLEXPANSION VAR)))
(QUOTE SUBPAT))
␈↓ εK (QUOTE CDR)))
(EVERY (CDDR (CADR PAT))
␈↓ εK (SETQ TEM1 (SUBSTVAR ('NLEFT (CADR TEM2)
(FUNCTION ARB?))
␈↓ εK ('PLUS SKIPEDLEN 1)
[COND
␈↓ εK NIL ZLENFLG)))
[(NLISTP (CADR (CADR PAT)))
␈↓ εK ('AND
(NOT (FMEMB (CADR (CADR PAT))
␈↓ εK [OR (NOT (EVERY (CDR PAT)
(QUOTE (& $ --]
␈↓ εK (FUNCTION CANMATCHNIL)))
(T (FMEMB (CAR (CADR (CADR PAT)))
␈↓ εK (COND
(QUOTE (= == ']
␈↓ εK ((ZEROP SKIPEDLEN)
(FMEMB [CAR (SETQ TEM1 ('MATCHELT
␈↓ εK TEM1)
(QUOTE DUMMY)
␈↓ εK (T ('CDR TEM1]
(CADR (CADR PAT]
␈↓ εK ('MATCHWM ('CDR TEM1)
(QUOTE (EQ EQUAL] (* PAT: (-- (SUBPAT
␈↓ εK (CDR PAT)
EQTYPE? ARB?) --))
␈↓ εK (QUOTE (TRUE)))
(RETURN
␈↓ εK (BLKAPPLY* (CAR FN)
('MATCHEXP
␈↓ εK ('LDIFF VAR ('CDR TEM1))
(LIST (SELECTQ (CAR TEM1)
␈↓ εK (CDR FN]
[EQ (CLISPLOOKUP (QUOTE ASSOC)
␈↓ εK [(ZEROP SKIPEDLEN)
VAR NIL
␈↓ εK (SETQ TEM1 (SUBSTVAR (LIST (QUOTE LAST)
(GETP (QUOTE ASSOC)
␈↓ εK VAR)))
(QUOTE LISPFN]
␈↓ εK ('AND (COND
(QUOTE SASSOC))
␈↓ εK ((CANMATCHNILLIST (CDR PAT))
(CADDR TEM1)
␈↓ εK TEM1))
VAR)
␈↓ εK ('MATCHWM ('CDR TEM1)
(CONS (QUOTE &)
␈↓ εK (CDR PAT)
(CDDR (CADR PAT)))
␈↓ εK (QUOTE (TRUE)))
NIL
␈↓ εK (BLKAPPLY* (CAR FN)
(QUOTE 'MATCHSUBPAT]
␈↓ εK ('LDIFF VAR ('CDR TEM1))
MAKESOME
␈↓ εK (CDR FN]
[RETURN (PROG ({OLD⎇ {FINALLY⎇EXPR {UNTIL⎇EXPR {ON⎇VAR
␈↓ εK (T
(TEMVAR (GENSYML))
␈↓ εK (SETQ TEM1 (SUBSTVAR ('NLEFT VAR SKIPEDLEN NIL
(INASOME (QUOTE INASOME)))
␈↓ εK ZLENFLG)))
(SETQ WATCHPOSTPONELST (CONS TEMVAR
␈↓ εK ('AND
WATCHPOSTPONELST))
␈↓ εK (OR (NOT (EVERY (CDR PAT)
␈↓ εK (FUNCTION CANMATCHNIL)))
(* WATCHPOSTPONELST is reset so that postponed uses
␈↓ εK TEM1)
of it can be detected; needed to set {OLD⎇)
␈↓ εK ('MATCHWM TEM1 (CDR PAT)
␈↓ εK (QUOTE (TRUE)))
␈↓ εK (BLKAPPLY* (CAR FN)
(COND
␈↓ εK ('LDIFF VAR TEM1)
((AND (REPLACED (CDR PAT))
␈↓ εK (CDR FN]
(EQ (CAR (SETQ TEM1 (FULLEXPANSION
␈↓ εK STARTWITH$N
VAR)))
␈↓ εK [RETURN (COND
(QUOTE CDR)))
␈↓ εK ((OR (NULL TAIL)
(SETQ {ON⎇VAR (CADR TEM1))
␈↓ εK (NULLPAT? TAIL))
(SETQ TEM2 ('CDR TEMVAR)))
␈↓ εK (OR (NOT CHECKINGLENGTH)
(T (SETQ {ON⎇VAR VAR)
␈↓ εK ('NOTLESSPLENGTH VAR SKIPEDLEN)))
(SETQ TEM2 TEMVAR)))
␈↓ εK [(NUMBERP SKIPEDLEN)
[SETQ {UNTIL⎇EXPR ('MATCHWM TEM2 (CDR PAT)
␈↓ εK ('MATCHWM ('NTH VAR (ADD1 SKIPEDLEN))
(QUOTE (TRUE]
␈↓ εK (CONS (CAR PAT)
(SETQ {FINALLY⎇EXPR
␈↓ εK TAIL)
('AND (BLKAPPLY* (CAR FN)
␈↓ εK (QUOTE (TRUE]
('LDIFF VAR TEM2)
␈↓ εK (T [SETQ TEM1 (SUBSTVAR ('NTH VAR ('PLUS SKIPEDLEN
(CDR FN))
␈↓ εK 1]
(OR (EQ INASOME (QUOTE INASOME))
␈↓ εK ('MATCHWM ('CDR TEM1)
(CONS (CAR PAT)
␈↓ εK (BLKAPPLY* FN VAR PAT 3RDARG))
TAIL)
␈↓ εK (T (PROG (TEM2)
(QUOTE (TRUE]
␈↓ εK (COND
LASTKLUDGE
␈↓ εK ([AND (REPLACED PAT)
(RETURN
␈↓ εK (FMEMB (CAR (SETQ TEM2 (FULLEXPANSION VAR)))
(COND
␈↓ εK (QUOTE (CAR CDR]
[[AND (CDDR PAT)
␈↓ εK (BLKAPPLY* FN (LIST (CAR TEM2)
(OR (SKIP$ANY (CDDR PAT))
␈↓ εK (SUBSTVAR (CADR TEM2)))
(NOT (ZEROP SKIPEDLEN]
␈↓ εK 3RDARG))
(PATWARN
␈↓ εK (T (BLKAPPLY* FN (SUBSTVAR VAR)
"Two arbitrary segments in a row - ignoring first")
␈↓ εK PAT 3RDARG])
('AND (BLKAPPLY* (CAR FN)
␈↓ εK
NIL
␈↓ εK␈↓↓('MATCHELT
␈↓
(CDR FN))
␈↓ εK [LAMBDA (VAR PATELT) (* This function matches
('MATCHWM VAR (CDR PAT)
␈↓ εK VAR against PATELT when
(QUOTE (TRUE]
␈↓ εK PATELT is a pattern
[(REPLACED (CDR PAT))
␈↓ εK element)
(SETQ TEM1 (SUBSTVAR ('NLEFT VAR 2)))
␈↓ εK (COND
('AND (OR (NOT (CANMATCHNILLIST (CDR PAT)))
␈↓ εK ((NLISTP PATELT)
TEM1)
␈↓ εK (SELECTQ PATELT
('MATCHWM ('CDR TEM1)
␈↓ εK (($ -- &)
(CDR PAT)
␈↓ εK T)
(QUOTE (TRUE)))
␈↓ εK ('EQUAL VAR PATELT)))
(BLKAPPLY* (CAR FN)
␈↓ εK (T (SELECTQ (CAR PATELT)
('LDIFF VAR ('CDR TEM1))
␈↓ εK (==('EQ VAR (CDR PATELT)))
(CDR FN]
␈↓ εK ['('EQUAL VAR (KWOTE (CDR PATELT]
(T (* Must mean the second
␈↓ εK (=('EQUAL VAR (CDR PATELT)))
is LAST)
␈↓ εK (SUBPAT ('MATCHSUBPAT VAR (CDR PATELT)))
(SETQ TEM1 (SUBSTVAR ('LAST VAR)))
␈↓ εK [$PACKED$ (OR (NOT CHECKINGLENGTH)
('AND ('MATCHWM TEM1 (CDR PAT)
␈↓ εK ('EQLENGTH VAR (CDR PATELT]
(QUOTE (TRUE)))
␈↓ εK (HELP "INVALID PATTERN"])
(BLKAPPLY* (CAR FN)
␈↓ εK
('LDIFF VAR TEM1)
␈↓ εK␈↓↓('MATCHSUBPAT
␈↓
(CDR FN])
␈↓ εK [LAMBDA (VAR PATELT)
␈↓ εK (PROG ((CHECKINGLENGTH PATCHECKLENGTH)
␈↓↓('MATCHTOP
␈↓␈↓ εK INASOME)
[LAMBDA (EXPRESSION PAT) (* Generate expresion
␈↓ εK ('MATCHWM VAR PATELT (QUOTE (TRUE])
which will match PAT
␈↓ εK)
against EXPRESSION)
␈↓ εK
(PROG ((GENSYMVARLIST (QUOTE (GENSYMVARS: $$1 $$2 $$3 $$4 $$5 $$6
␈↓ εK␈↓↓(* Funargs for 'MATCHWM)
␈↓
$$7 $$8 $$9 $$10 $$11
␈↓ εK
$$12 $$13 $$14 $$15 $$16
␈↓ εK␈↓↓(DEFINEQ
␈↓
$$17)))
␈↓ εK
(CHECKINGLENGTH PATCHECKLENGTH)
␈↓ εK␈↓↓(MAKE'SETQ
␈↓
POSTPONEDEFFECTS LASTEFFECTCANBENIL BINDINGS MUSTRETURN
␈↓ εK [LAMBDA (X ARGS) (* CAR ARGS is old PAT,
WMLST ZLENFLG SUBLIST INASOME WATCHPOSTPONELST)
␈↓ εK CDR ARGS is old FN)
␈↓ εK ('AND ['SETQ (CAR (CAR ARGS))
(* POSTPONEDEFFECTS is the side effects postponed -
␈↓ εK X
BINDINGS will be list of prog bindings that need to
␈↓ εK (CANMATCHNIL (CDR (CAR ARGS]
be done -
␈↓ εK (BLKAPPLY* (CAR (CDR ARGS))
MUSTRETURN will be the * expression, if any)
␈↓ εK X
␈↓ εK (CDDR ARGS])
␈↓ εK
(SETQ EXPRESSION ('MATCHEXP EXPRESSION PAT (QUOTE (TRUE))
␈↓ εK␈↓↓(MAKEPOSTPONEDSETQ
␈↓
(QUOTE 'MATCHWM)))
␈↓ εK [LAMBDA (X ARGS) (* CAR ARGS is old PAT,
[COND
␈↓ εK CDR ARGS is old FN)
(MUSTRETURN (SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS
␈↓ εK ('AND [POSTPONEDSETQ (CAR (CAR ARGS))
MUSTRETURN)))
␈↓ εK X
((AND LASTEFFECTCANBENIL PATCAREVALUE)
␈↓ εK (CANMATCHNIL (CDR (CAR ARGS]
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS T]
␈↓ εK (BLKAPPLY* (CAR (CDR ARGS))
[COND
␈↓ εK X
(POSTPONEDEFFECTS (SETQ EXPRESSION ('AND EXPRESSION
␈↓ εK (CDDR ARGS])
('PROGN
␈↓ εK
POSTPONEDEFFECTS]
␈↓ εK␈↓↓(MAKE'REPLACE
␈↓
(AND SUBLIST (SETQ EXPRESSION (MAKESUBSTLIST (DREVERSE
␈↓ εK [LAMBDA (X ARGS) (* CAR ARGS is old PAT,
SUBLIST)
␈↓ εK CDR ARGS is old FN)
EXPRESSION)))
␈↓ εK ('AND ('REPLACE X (CAR (CAR ARGS)))
(RETURN (COND
␈↓ εK (BLKAPPLY* (CAR (CDR ARGS))
(BINDINGS ('PROG BINDINGS (LIST EXPRESSION)))
␈↓ εK X
(T EXPRESSION])
␈↓ εK (CDDR ARGS])
␈↓ εK
␈↓↓('MATCHEXP
␈↓␈↓ εK␈↓↓(MAKEPOSTPONEDREPLACE
␈↓
[LAMBDA (VAR PAT 3RDARG FN)
␈↓ εK [LAMBDA (X ARGS) (* CAR ARGS is old PAT,
(COND
␈↓ εK CDR ARGS is old FN)
((EASYTORECOMPUTE VAR)
␈↓ εK ('AND (POSTPONEDREPLACE X (CAR (CAR ARGS)))
(BLKAPPLY* (CAR (CDR ARGS))
␈↓ εK ((ZEROP TEM)
X
␈↓ εK (SETQ ZLENFLG T))
(CDDR ARGS])
␈↓ εK (T (SETQ SKIPEDLEN ('PLUS SKIPEDLEN TEM]
␈↓ εK NIL)
␈↓↓(MAKE'APPLY*
␈↓␈↓ εK (T T])
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
␈↓ εK
CDR ARGS is old FN)
␈↓ εK␈↓↓(PATLEN
␈↓
('AND ('APPLY* (CAR (CAR ARGS))
␈↓ εK [LAMBDA (PATELT !ED)
X)
␈↓ εK (PROG NIL
(BLKAPPLY* (CAR (CDR ARGS))
␈↓ εK LP (RETURN
X
␈↓ εK (COND
(CDDR ARGS])
␈↓ εK [(NLISTP PATELT)
␈↓ εK (SELECTQ PATELT
␈↓↓(MAKE'RETURN
␈↓␈↓ εK (($ --)
[LAMBDA (X ARGS) (* ARGS is old FN)
␈↓ εK NIL)
(DOWATCH X)
␈↓ εK (& (AND (NOT !ED)
('AND ('RETURN X)
␈↓ εK 1))
(BLKAPPLY* (CAR ARGS)
␈↓ εK (COND
X
␈↓ εK (!ED 0)
(CDR ARGS])
␈↓ εK (T 1]
␈↓ εK (T
␈↓↓(MAKE*GLITCH
␈↓␈↓ εK (SELECTQ
[LAMBDA (X ARGS) (* CAR ARGS is old PAT,
␈↓ εK (CAR PATELT)
CDR ARGS is old
␈↓ εK (* (SETQ PATELT (CDR PATELT))
(CDR ARGS))
␈↓ εK (GO LP))
(FRPLACA (CAR (CAR ARGS))
␈↓ εK (SUBPAT (COND
X)
␈↓ εK [!ED (for PE1 in (CDR PATELT) bind PLEN←0
(DOWATCH X)
␈↓ εK finally (RETURN PLEN)
(BLKAPPLY* (CAR (CDR ARGS))
␈↓ εK do (SETQ PLEN
X
␈↓ εK ('PLUS PLEN
(CDDR ARGS])
␈↓ εK (OR (PATLEN PE1)
)
␈↓ εK (RETURN NIL]
␈↓ εK (T 1)))
␈↓↓(* PREDICATES ON PATTERNS)
␈↓␈↓ εK ($PACKED$ (CDR PATELT))
␈↓ εK ((← -> <- → @ *GLITCH)
␈↓↓(DEFINEQ
␈↓␈↓ εK (SETQ PATELT (CDDR PATELT))
␈↓ εK (GO LP))
␈↓↓(SKIP$I
␈↓␈↓ εK (! (SETQ PATELT (CDR PATELT))
[LAMBDA (PAT)
␈↓ εK (SETQ !ED T)
␈↓ εK (GO LP))
(* Returns to the first TAIL of PAT which doesn't
␈↓ εK ('(COND
begin with a $i or a $$foo -
␈↓ εK (!ED (LENGTH (CDR PATELT)))
Sets the variable "LEN" to the total length of
␈↓ εK (T 1)))
things skipped over)
␈↓ εK ((= ==)
␈↓ εK (AND (NOT !ED)
␈↓ εK 1))
(SOME PAT (FUNCTION (LAMBDA (ELT)
␈↓ εK (HELP "INVALID PATTERN" PATELT])
(COND
␈↓ εK
((EQ ELT (QUOTE &))
␈↓ εK␈↓↓($?
␈↓
(SETQ SKIPEDLEN ('PLUS 1 SKIPEDLEN))
␈↓ εK [LAMBDA (PATELT)
NIL)
␈↓ εK (OR (EQ PATELT (QUOTE --))
((EQ (CAR ELT)
␈↓ εK (EQ PATELT (QUOTE $])
(QUOTE $PACKED$))
␈↓ εK
(SETQ SKIPEDLEN ('PLUS SKIPEDLEN (CDR ELT)))
␈↓ εK␈↓↓(ELT?
␈↓
NIL)
␈↓ εK [LAMBDA (PATELT)
(T])
␈↓ εK (COND
␈↓ εK [(NLISTP PATELT)
␈↓↓(SKIP$ANY
␈↓␈↓ εK (OR (NUMBERP PATELT)
[LAMBDA (PAT)
␈↓ εK (STRINGP PATELT)
␈↓ εK (FMEMB PATELT (QUOTE (& NIL T]
(* Scans PAT until a pattern element which matches
␈↓ εK (T (SELECTQ (CAR PATELT)
an arbitrary length segment is hit)
␈↓ εK ((= == ' SUBPAT)
␈↓ εK T)
␈↓ εK ((← -> <- → @ *GLITCH)
␈↓ εK (ELT? (CDDR PATELT)))
(* The free variables SETS and MATCH are set to T if
␈↓ εK ( (*)
a set or MATCH (respectively) are found in any of
␈↓ εK (ELT? (CDR PATELT)))
the pattern elements passed over)
␈↓ εK NIL])
␈↓ εK
␈↓ εK␈↓↓(ARB?
␈↓
(SOME PAT (FUNCTION (LAMBDA (ELT)
␈↓ εK [LAMBDA (PATELT)
(PROG (TEM)
␈↓ εK (COND
(COND
␈↓ εK ((NLISTP PATELT)
((SETQ TEM (PATLEN ELT))
␈↓ εK ($? PATELT))
[COND
␈↓ εK (T (SELECTQ (CAR PATELT)
(! NIL)
␈↓ εK (HELP "Invalid pattern?" PATELT])
(* (ARB? (CDR PATELT)))
␈↓ εK
((<- → ← -> *GLITCH)
␈↓ εK␈↓↓(REPLACED
␈↓
(ARB? (CDDR PATELT)))
␈↓ εK [LAMBDA (PAT)
NIL])
␈↓ εK (for X in PAT do (COND
␈↓ εK ((ELT? X)
␈↓↓(NULLPAT?
␈↓␈↓ εK (RETURN))
[LAMBDA (PAT)
␈↓ εK ((REPLACEIN X)
(AND PAT (EVERY PAT (FUNCTION $?])
␈↓ εK (RETURN T])
␈↓ εK)
␈↓↓(CANMATCHNIL
␈↓␈↓ εK
[LAMBDA (PATELT)
␈↓ εK␈↓↓(* LISP FUNCTION MANIPULATION)
␈↓
␈↓ εK
(* Returns T if PATELT matches NIL, NIL if it
␈↓ εK␈↓↓(DEFINEQ
␈↓
doesn't, and something ELSE
␈↓ εK
(maybe) if it might (e.g., =FOO))
␈↓ εK␈↓↓(EASYTORECOMPUTE
␈↓
␈↓ εK [LAMBDA (EXPRESSION)
␈↓ εK
(COND
␈↓ εK (* If the EXPRESSION is some cadddaars of a
((NLISTP PATELT)
␈↓ εK variable, return that variable
(AND (FMEMB PATELT (QUOTE (& NIL $ --)))
␈↓ εK (something needs to check for VARS bound IN somes
T))
␈↓ εK and internal forms for WHEN it can't use it for the
((NLISTP (CAR PATELT))
␈↓ εK *'s value))
(SELECTQ (CAR PATELT)
␈↓ εK
[@ (AND (CANMATCHNIL (CDDR PATELT))
␈↓ εK
[NOT (FMEMB (CADR PATELT)
␈↓ εK (OR (AND (NLISTP EXPRESSION)
(QUOTE (GETD NUMBERP STRINGP ZEROP
␈↓ εK EXPRESSION)
LISTP SUBPR]
␈↓ εK (AND [OR (GETP (CAR EXPRESSION)
(QUOTE (MAYBE, MAYBE NOT]
␈↓ εK (QUOTE CROPS))
(* (CANMATCHNIL (CDR PATELT)))
␈↓ εK (FMEMB (CAR EXPRESSION)
(SUBPAT (CANMATCHNILLIST (CDR PATELT)))
␈↓ εK (QUOTE (CAR CDR]
($PACKED$ (OR (NOT (NUMBERP (CDR PATELT)))
␈↓ εK (EASYTORECOMPUTE (CADR EXPRESSION])
(ILESSP (CDR PATELT)
␈↓ εK
2)))
␈↓ εK␈↓↓(FULLEXPANSION
␈↓
((← -> → <- *GLITCH)
␈↓ εK [LAMBDA (X)
(CANMATCHNIL (CDDR PATELT)))
␈↓ εK (PROG (TEM)
(! (CANMATCHNIL (CDR PATELT)))
␈↓ εK (COND
('(NULL (CDR PATELT)))
␈↓ εK ([OR (EQ (CAR X)
((= ==)
␈↓ εK (QUOTE CAR))
(QUOTE MAYBE))
␈↓ εK (EQ (CAR X)
(HELP "INVALID PATTERN" PATELT)))
␈↓ εK (QUOTE CDR))
(T (HELP "INVALID PATTERN ELEMENT"])
␈↓ εK (NULL (SETQ TEM (FASSOC (CAR X)
␈↓ εK CRLIST]
␈↓↓(CANMATCHNILLIST
␈↓␈↓ εK X)
[LAMBDA (PATLIST)
␈↓ εK (T (LIST (CADDDR TEM)
(EVERY PATLIST (FUNCTION (LAMBDA (PE)
␈↓ εK (LIST (CAR (CDDDDR TEM))
(AND (NOT (ELT? PE))
␈↓ εK (CADR X])
(CANMATCHNIL PE])
␈↓ εK
␈↓ εK␈↓↓(GENSYML
␈↓
␈↓↓(REPLACEIN
␈↓␈↓ εK [LAMBDA NIL
[LAMBDA (PATELT)
␈↓ εK (OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(AND (LISTP PATELT)
␈↓ εK (GENSYM])
(SELECTQ (CAR PATELT)
␈↓ εK
((-> → *GLITCH)
␈↓ εK␈↓↓(MAKESUBST0
␈↓
␈↓ εK [LAMBDA (OLD NEW)
(* the *GLITCH might or might not be a replace, but
␈↓ εK (SETQ SUBLIST (CONS (LIST OLD NEW)
can't take any chances)
␈↓ εK SUBLIST])
␈↓ εK
␈↓ εK␈↓↓(MAKESUBSTLIST
␈↓
T)
␈↓ εK [LAMBDA (SUBPRS EXPR)
((@ ← <-)
␈↓ εK
(REPLACEIN (CDDR PATELT)))
␈↓ εK (* This function substitues , for each element of
(*
␈↓ εK SUBPR (OLD . NEW) -
␈↓ εK if OLD is found only once in EXPRESSION, then it is
(* LEAVE ROOM FOR POSS THAT X:
␈↓ εK directly substituted -
(-- 'A --) ←FOO CONSTRUCTS MIGHT ARISE)
␈↓ εK otherwise, a temp var is made up, bound,
␈↓ εK (SETQ tem NEW) is substituted for the first
␈↓ εK occurance, and the temp var for the rest)
(REPLACEIN (CDR PATELT)))
␈↓ εK
(! (REPLACEIN (CDR PATELT)))
␈↓ εK
(SUBPAT (SOME (CDR PATELT)
␈↓ εK (PROG NIL
(FUNCTION REPLACEIN)))
␈↓ εK LP (COND
(($PACKED$ ≠ ≠≠ = == ') (* Not needed -
␈↓ εK [(NLISTP EXPR)
really LMDEBUG)
␈↓ εK (COND
NIL)
␈↓ εK ((NULL SUBPRS)
(RETURN EXPR))
␈↓ εK
(T [COND
␈↓ εK␈↓↓(SUBSTVAR
␈↓
((EQ (CAAR SUBPRS)
␈↓ εK [LAMBDA (EXPR)
EXPR)
␈↓ εK (PROG (TEM)
(SETQ EXPR (CADAR SUBPRS]
␈↓ εK (MAKESUBST0 (SETQ TEM (GENSYML))
(SETQ SUBPRS (CDR SUBPRS))
␈↓ εK EXPR)
(GO LP]
␈↓ εK (RETURN TEM])
(SUBPRS (RETURN (OR (MAKESUBSTLIST1 EXPR)
␈↓ εK
EXPR)))
␈↓ εK␈↓↓(BOUNDVAR
␈↓
(T (RETURN EXPR])
␈↓ εK [LAMBDA NIL
␈↓ εK (BINDVAR (GENSYML])
␈↓↓(MAKESUBSTLIST1
␈↓␈↓ εK
[LAMBDA (EXPRESSION)
␈↓ εK␈↓↓(BINDVAR
␈↓
(PROG (TEM1 TEM2)
␈↓ εK [LAMBDA (VAR)
(COND
␈↓ εK (SETQ BINDINGS (CONS VAR BINDINGS))
((NLISTP EXPRESSION)
␈↓ εK VAR])
NIL)
␈↓ εK
((SETQ TEM1 (FASSOC (CAR EXPRESSION)
␈↓ εK␈↓↓(SELFQUOTEABLE
␈↓
SUBPRS))
␈↓ εK [LAMBDA (EXPRESSION)
(SETQ EXPRESSION (CONS (CAR EXPRESSION)
␈↓ εK (OR (NUMBERP EXPRESSION)
(CDR EXPRESSION)))
␈↓ εK (STRINGP EXPRESSION)
(COND
␈↓ εK (NULL EXPRESSION)
((LISTP (CDDR TEM1))
␈↓ εK (EQ EXPRESSION T])
(SETQ TEM2 (BOUNDVAR))
␈↓ εK
(FRPLACA (CDDR TEM1)
␈↓ εK␈↓↓(FINDIN0
␈↓
('SETQ TEM2 (CADDR TEM1)))
␈↓ εK [LAMBDA (VAR EXPR)
(FRPLACA (CDR TEM1)
␈↓ εK (OR (FINDIN1 VAR EXPR)
TEM2)
␈↓ εK (SOME SUBLIST (FUNCTION (LAMBDA (X)
(FRPLACD (CDR TEM1)
␈↓ εK (AND (FINDIN1 (CAR X)
T))
␈↓ εK EXPR)
((NULL (CDDR TEM1)) (* Haven't seen it
␈↓ εK (FINDIN1 VAR (CDR X])
before)
␈↓ εK
(FRPLACD (CDR TEM1)
␈↓ εK␈↓↓(FINDIN1
␈↓
EXPRESSION)))
␈↓ εK [LAMBDA (AT LST) (* CHEAP EDITFINDP)
(FRPLACA EXPRESSION (OR (MAKESUBSTLIST1 (CADR TEM1))
␈↓ εK (OR (EQ AT LST)
(CADR TEM1)))
␈↓ εK (AND (LISTP LST)
(FRPLACD EXPRESSION (OR (MAKESUBSTLIST1 (CDR EXPRESSION))
␈↓ εK (OR (FINDIN1 AT (CAR LST))
(CDR EXPRESSION)))
␈↓ εK (FINDIN1 AT (CDR LST])
EXPRESSION)
␈↓ εK
(T (PROG (A D)
␈↓ εK␈↓↓(DOWATCH
␈↓
(SETQ A (MAKESUBSTLIST1 (CAR EXPRESSION)))
␈↓ εK [LAMBDA (EXPR)
(SETQ D (MAKESUBSTLIST1 (CDR EXPRESSION)))
␈↓ εK (AND WATCHPOSTPONELST (MAP WATCHPOSTPONELST
(AND (OR A D)
␈↓ εK (FUNCTION (LAMBDA (X)
(CONS (OR A (CAR EXPRESSION))
␈↓ εK (AND (NEQ (CAR X)
(OR D (CDR EXPRESSION])
␈↓ εK (QUOTE FOUND))
␈↓ εK (FINDIN0 (CAR X)
␈↓↓(FORMEXPAND
␈↓␈↓ εK EXPR)
[LAMBDA (LIST AT)
␈↓ εK (FRPLACA X (QUOTE FOUND])
␈↓ εK
(* Searches for (AT --) AT the top level of list and
␈↓ εK␈↓↓(UNCROP
␈↓
does a (1) up (bo 1) on them)
␈↓ εK [LAMBDA (EXPR)
␈↓ εK (COND
␈↓ εK ((NLISTP EXPR)
[for X on LIST do (AND (EQ (CAAR X)
␈↓ εK EXPR)
AT)
␈↓ εK ((GETP (CAR EXPR)
(FRPLACD X (NCONC (CDDAR X)
␈↓ εK (QUOTE CROPS))
(CDR X)))
␈↓ εK (UNCROP (CADR EXPR)))
(FRPLACA X (CADAR X]
␈↓ εK (T (SELECTQ (CAR EXPR)
LIST])
␈↓ εK ((CAR CDR NTH NLEFT LAST FLAST FNTH SOME)
␈↓ εK (UNCROP (CADR EXPR)))
␈↓↓(POSTPONEDREPLACE
␈↓␈↓ εK ((MEMB FMEMB MEMBER)
[LAMBDA (VAR VALUE)
␈↓ εK (UNCROP (CADDR EXPR)))
(POSTPONE ('REPLACE VAR VALUE])
␈↓ εK EXPR])
␈↓ εK)
␈↓↓(POSTPONEDSETQ
␈↓␈↓ εK
[LAMBDA (VARTOSET VALUE CANBENILFLG)
␈↓ εK␈↓↓(* LISP FUNCTION CONSTRUCTION)
␈↓
(POSTPONE ('SETQ VARTOSET VALUE)
␈↓ εK
CANBENILFLG])
␈↓ εK␈↓↓(DEFINEQ
␈↓
␈↓ εK
␈↓↓(POSTPONE
␈↓␈↓ εK␈↓↓('NLEFT
␈↓
[LAMBDA (EFFECT FLG)
␈↓ εK [LAMBDA (EXPRESSION N TAIL NOTFASTFLG)
(SETQ LASTEFFECTCANBENIL FLG)
␈↓ εK (COND
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS EFFECT))
␈↓ εK (TAIL (LIST (QUOTE NLEFT)
(DOWATCH EFFECT)
␈↓ εK EXPRESSION N TAIL))
T])
␈↓ εK ((ZEROP N) (* NO LOOKUP DONE SINCE
FLAST DOESN'T MAKE SENSE
␈↓ εK ((EQ LEN 5)
HERE)
␈↓ εK (LIST (QUOTE CDDDDR)
(LIST (QUOTE CDR)
␈↓ εK VAR))
(LIST (QUOTE LAST)
␈↓ εK (T (WHILE (IGREATERP LEN 5)
EXPRESSION)))
␈↓ εK DO (SETQ VAR (LIST (QUOTE CDDDDR)
[(EQ N 1)
␈↓ εK VAR))
(COND
␈↓ εK (SETQ LEN (IDIFFERENCE LEN 4)))
(NOTFASTFLG (LIST (QUOTE LAST)
␈↓ εK (GO LP])
EXPRESSION))
␈↓ εK
(T ('LAST EXPRESSION]
␈↓ εK␈↓↓('OR
␈↓
(T (LIST (QUOTE NLEFT)
␈↓ εK [LAMBDA (LISTOFEXPRESSIONS)
EXPRESSION N])
␈↓ εK (COND
␈↓ εK [(CDR LISTOFEXPRESSIONS)
␈↓↓('NOT
␈↓␈↓ εK (CONS (QUOTE OR)
[LAMBDA (X)
␈↓ εK (FORMEXPAND LISTOFEXPRESSIONS (QUOTE OR]
('NOT1 X (QUOTE NOT])
␈↓ εK (T (CAR LISTOFEXPRESSIONS])
␈↓ εK
␈↓↓('NULL
␈↓␈↓ εK␈↓↓('PLUS
␈↓
[LAMBDA (X)
␈↓ εK [LAMBDA (EXPR1 EXPR2)
('NOT1 X (QUOTE NULL])
␈↓ εK (COND
␈↓ εK ((AND (NUMBERP EXPR1)
␈↓↓('NOT1
␈↓␈↓ εK (NUMBERP EXPR2))
[LAMBDA (X FNNAME)
␈↓ εK (IPLUS EXPR1 EXPR2))
(COND
␈↓ εK (T (PROG ((SUM 0)
((NLISTP X)
␈↓ εK (LST (FORMEXPAND (LIST EXPR1 EXPR2)
(SELECTQ X
␈↓ εK (QUOTE IPLUS)))
(NIL T)
␈↓ εK VAL)
(T NIL)
␈↓ εK [FOR X in LST do (COND
(LIST FNNAME X)))
␈↓ εK ((NUMBERP X)
(T (SELECTQ (CAR X)
␈↓ εK (SETQ SUM (IPLUS X SUM)))
((NOT NULL)
␈↓ εK (T (SETQ VAL (NCONC1 VAL X]
(CADR X))
␈↓ εK (COND
(EQ (FRPLACA X (QUOTE NEQ)))
␈↓ εK ((NULL VAL) SUM)
(NEQ (FRPLACA X (QUOTE EQ)))
␈↓ εK ((IGREATERP SUM 0)
[(OR AND)
␈↓ εK (CONS (QUOTE IPLUS)
[for Y on (CDR X)
␈↓ εK (CONS SUM VAL)))
do (FRPLACA Y ('NOT (CAR Y]
␈↓ εK ((NULL (CDR VAL))
(FRPLACA X (COND
␈↓ εK (CAR VAL))
((EQ (CAR X)
␈↓ εK (T (CONS (QUOTE IPLUS)
(QUOTE AND))
␈↓ εK VAL])
(QUOTE OR))
␈↓ εK
(T (QUOTE OR]
␈↓ εK␈↓↓('REPLACE
␈↓
(LISTP (RPLACA X (QUOTE NLISTP)))
␈↓ εK [LAMBDA (VAR EXPRESSION)
(NLISTP (FRPLACA X (QUOTE LISTP)))
␈↓ εK (SETQ VAR (FULLEXPANSION VAR))
(LIST FNNAME X])
␈↓ εK (COND
␈↓ εK ((EQ (CAR VAR)
␈↓↓('NOTLESSPLENGTH
␈↓␈↓ εK (QUOTE CAR))
[LAMBDA (X N)
␈↓ εK (LIST (CLISPLOOKUP (QUOTE RPLACA)
(COND
␈↓ εK (CADR VAR)
((ZEROP N)
␈↓ εK EXPRESSION
T)
␈↓ εK (GETP (QUOTE RPLACA)
(T ('NTH X N])
␈↓ εK (QUOTE LISPFN)))
␈↓ εK (CADR VAR)
␈↓↓('NTH
␈↓␈↓ εK EXPRESSION))
[LAMBDA (VAR LEN)
␈↓ εK ((EQ (CAR VAR)
(COND
␈↓ εK (QUOTE CDR))
((OR (NOT (NUMBERP LEN))
␈↓ εK (LIST (CLISPLOOKUP (QUOTE RPLACD)
(IGREATERP LEN MAXCDDDDRS))
␈↓ εK (CADR VAR)
(LIST (CLISPLOOKUP (QUOTE NTH)
␈↓ εK EXPRESSION
VAR LEN (GETP (QUOTE NTH)
␈↓ εK (GETP (QUOTE RPLACD)
(QUOTE LISPFN)))
␈↓ εK (QUOTE LISPFN)))
VAR LEN))
␈↓ εK (CADR VAR)
(T (PROG NIL
␈↓ εK EXPRESSION))
LP (COND
␈↓ εK [(EQ (CAR VAR)
((EQ LEN 1)
␈↓ εK (QUOTE LDIFF))
VAR)
␈↓ εK ('REPLACE (CADR VAR)
((EQ LEN 2)
␈↓ εK (LIST (QUOTE NCONC)
(LIST (QUOTE CDR)
␈↓ εK EXPRESSION
VAR))
␈↓ εK (CADDR VAR]
((EQ LEN 3)
␈↓ εK (T (HELP "You are simply unreplaceable!!" VAR)
(LIST (QUOTE CDDR)
␈↓ εK (LIST (QUOTE RPLNODE2)
VAR))
␈↓ εK VAR EXPRESSION])
((EQ LEN 4)
␈↓ εK
(LIST (QUOTE CDDDR)
␈↓ εK␈↓↓('SETQ
␈↓
VAR))
␈↓ εK [LAMBDA (VAR EXPRESSION PROGNFLG)
(SETQ EXPRESSION (LIST (QUOTE SETQ)
␈↓ εK (EQ (CAADR EXPR1)
VAR EXPRESSION))
␈↓ εK (QUOTE SETQ))
(COND
␈↓ εK (EQ (CADDR EXPR1)
(PROGNFLG (LIST (QUOTE PROGN)
␈↓ εK T)
EXPRESSION T))
␈↓ εK (SETQ TEM (CADR EXPR1]
(T EXPRESSION])
␈↓ εK (COND
␈↓ εK ((EQ EXPR2 (CADR TEM))
␈↓↓('AND
␈↓␈↓ εK TEM)
[LAMBDA N
␈↓ εK ((AND (EQ (CAR EXPR2)
(PROG ((NARGS N)
␈↓ εK (QUOTE AND))
EXPR1 EXPR2)
␈↓ εK (EQ (CADR TEM)
(SETQ EXPR2 (ARG N NARGS))
␈↓ εK (CADR EXPR2)))
LP (SETQ NARGS (SUB1 NARGS))
␈↓ εK (FRPLACA (CDR EXPR2)
(COND
␈↓ εK TEM)
((ZEROP NARGS)
␈↓ εK EXPR2]
(RETURN EXPR2)))
␈↓ εK (T (LIST (QUOTE AND)
(SETQ EXPR1 (ARG N NARGS))
␈↓ εK EXPR1 EXPR2])
(SETQ EXPR2 ('AND2 EXPR1 EXPR2))
␈↓ εK
(GO LP])
␈↓ εK␈↓↓('CAR
␈↓
␈↓ εK [LAMBDA (X)
␈↓↓('AND2
␈↓␈↓ εK (PROG (TEM)
[LAMBDA (EXPR1 EXPR2)
␈↓ εK (COND
(PROG (TEM)
␈↓ εK ([NULL (SETQ TEM (CADR (FASSOC (CAR X)
(COND
␈↓ εK CRLIST]
((EQ EXPR1 T)
␈↓ εK (LIST (QUOTE CAR)
EXPR2)
␈↓ εK X))
((EQ EXPR2 T)
␈↓ εK (T (LIST TEM (CADR X])
EXPR1)
␈↓ εK
((EQUAL EXPR1 (UNCROP EXPR2))
␈↓ εK␈↓↓('CDR
␈↓
EXPR2)
␈↓ εK [LAMBDA (X)
((EQ (CAR EXPR1)
␈↓ εK (PROG (TEM)
(QUOTE PROGN))
␈↓ εK (COND
(SETQ TEM (FLAST EXPR1))
␈↓ εK ([NULL (SETQ TEM (CADDR (FASSOC (CAR X)
(FRPLACA TEM ('AND (CAR TEM)
␈↓ εK CRLIST]
EXPR2))
␈↓ εK (LIST (QUOTE CDR)
EXPR1)
␈↓ εK X))
((AND (EQ (CAR EXPR2)
␈↓ εK (T (LIST TEM (CADR X])
(QUOTE COND))
␈↓ εK
(NOT (CDDR EXPR2)))
␈↓ εK␈↓↓('EQ
␈↓
(FRPLACA (CADR EXPR2)
␈↓ εK [LAMBDA (VAR EXPRESSION)
('AND EXPR1 (CAADR EXPR2)))
␈↓ εK (COND
EXPR2)
␈↓ εK ((NULL EXPRESSION)
((AND (EQ (CAR EXPR1)
␈↓ εK ('NULL VAR))
(QUOTE COND))
␈↓ εK ((ZEROP EXPRESSION)
(NULL (CDDR EXPR1)))
␈↓ εK (LIST (QUOTE ZEROP)
(FRPLACA (SETQ TEM (FLAST (CADR EXPR1)))
␈↓ εK VAR))
('AND (CAR TEM)
␈↓ εK (T (LIST (QUOTE EQ)
EXPR2))
␈↓ εK VAR EXPRESSION])
EXPR1)
␈↓ εK
((AND (EQ (CAR EXPR2)
␈↓ εK␈↓↓('EQLENGTH
␈↓
(QUOTE OR))
␈↓ εK [LAMBDA (VAR LEN)
(EQ (CADDR EXPR2)
␈↓ εK
T))
␈↓ εK (* THIS SHOULD REALLY TAKE
(LIST (QUOTE COND)
␈↓ εK (EQLENGTH (CDDDR X) 10) AND TRANSLATE IT TO
(LIST EXPR1 (CADR EXPR2)
␈↓ εK (EQLENGTH X 13))
T)))
␈↓ εK
[(EQ (CAR EXPR2)
␈↓ εK
(QUOTE PROGN))
␈↓ εK (COND
(LIST (QUOTE COND)
␈↓ εK ((EQ (CAR VAR)
(CONS EXPR1 (CDR EXPR2]
␈↓ εK (QUOTE CDR))
[(EQ (CAR EXPR2)
␈↓ εK ('EQLENGTH (CADR VAR)
(QUOTE AND))
␈↓ εK ('PLUS LEN 1)))
(COND
␈↓ εK ((EQ (CAR VAR)
((EQ (CAR EXPR1)
␈↓ εK (QUOTE CDDR))
(QUOTE AND))
␈↓ εK ('EQLENGTH (CADR VAR)
(NCONC EXPR1 (CDR EXPR2)))
␈↓ εK ('PLUS LEN 2)))
(T (FRPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
␈↓ εK ((EQ (CAR VAR)
((EQ (CAR EXPR1)
␈↓ εK (QUOTE CDDDDR))
(QUOTE AND))
␈↓ εK ('EQLENGTH (CADR VAR)
(NCONC1 EXPR1 EXPR2))
␈↓ εK ('PLUS LEN 3)))
[(AND [OR (AND (EQ (CAR EXPR1)
␈↓ εK ((EQ (CAR VAR)
(QUOTE SETQ))
␈↓ εK (QUOTE CDDDR))
(SETQ TEM EXPR1))
␈↓ εK ('EQLENGTH (CADR VAR)
(AND (EQ (CAR EXPR1)
␈↓ εK ('PLUS LEN 3)))
(QUOTE OR))
␈↓ εK ((ZEROP LEN)
('NULL VAR))
␈↓ εK ('EQUAL ('CAR TAILVAR)
(T (LIST (QUOTE EQLENGTH)
␈↓ εK ('CAR VAR)))
VAR LEN])
␈↓ εK ('SETQ TAILVAR ('CDR TAILVAR))
␈↓ εK ('SETQ VAR ('CDR VAR))
␈↓↓('EQUAL
␈↓␈↓ εK (QUOTE (GO $$LP])
[LAMBDA (VAR EXPRESSION)
␈↓ εK
[COND
␈↓ εK␈↓↓('LDIFF
␈↓
((AND (EQ (CAR EXPRESSION)
␈↓ εK [LAMBDA (X Y)
(QUOTE QUOTE))
␈↓ εK (LIST (QUOTE LDIFF)
(SELFQUOTEABLE (CADR EXPRESSION)))
␈↓ εK X Y])
(SETQ EXPRESSION (CADR EXPRESSION]
␈↓ εK
(COND
␈↓ εK␈↓↓('PROG
␈↓
((NULL EXPRESSION)
␈↓ εK [LAMBDA (VARS STATEMENTS)
('NULL VAR))
␈↓ εK (COND
((EQ EXPRESSION T)
␈↓ εK ((AND (NULL (CDR STATEMENTS))
('EQ VAR EXPRESSION))
␈↓ εK (EQ (CAAR STATEMENTS)
(T (LIST (COND
␈↓ εK (QUOTE PROG)))
([OR (SMALLP EXPRESSION)
␈↓ εK (RPLACA (CDAR STATEMENTS)
(AND (EQ (CAR EXPRESSION)
␈↓ εK (APPEND (CADAR STATEMENTS)
(QUOTE QUOTE))
␈↓ εK VARS))
(LITATOM (CADR EXPRESSION]
␈↓ εK (CAR STATEMENTS))
(QUOTE EQ))
␈↓ εK (T (CONS (QUOTE PROG)
((NUMBERP EXPRESSION)
␈↓ εK (CONS VARS STATEMENTS])
(QUOTE EQP))
␈↓ εK
((STRINGP EXPRESSION)
␈↓ εK␈↓↓('FOR
␈↓
(QUOTE STREQUAL))
␈↓ εK [LAMBDA ({OLD⎇ I.V. {ON⎇VAR {UNTIL⎇EXPR {FINALLY⎇EXPR NOSOMEFLG)
(T (QUOTE EQUAL)))
␈↓ εK (PROG (TEM1)
VAR EXPRESSION])
␈↓ εK (COND
␈↓ εK (NOSOMEFLG (GO DOPROG)))
␈↓↓('LAST
␈↓␈↓ εK (SELECTQ (CAR {UNTIL⎇EXPR)
[LAMBDA (X)
␈↓ εK [EQ (AND (EQUAL (CADR {UNTIL⎇EXPR)
(LIST (CLISPLOOKUP (QUOTE LAST)
␈↓ εK ('CAR I.V.))
X NIL (GETP (QUOTE LAST)
␈↓ εK (SETQ TEM1
(QUOTE LISPFN)))
␈↓ εK (LIST (CLISPLOOKUP (QUOTE MEMB)
X])
␈↓ εK {ON⎇VAR NIL
␈↓ εK (GETP (QUOTE MEMB)
␈↓↓('RETURN
␈↓␈↓ εK (QUOTE LISPFN)))
[LAMBDA (VALUE)
␈↓ εK (CADDR {UNTIL⎇EXPR)
(COND
␈↓ εK {ON⎇VAR]
(STARREPLACED ('REPLACE VALUE STARREPLACED))
␈↓ εK [EQUAL (AND (EQUAL (CADR {UNTIL⎇EXPR)
(T (SETQ MUSTRETURN VALUE)
␈↓ εK ('CAR I.V.))
T])
␈↓ εK (SETQ TEM1 (LIST (QUOTE MEMBER)
␈↓ εK (CADDR {UNTIL⎇EXPR)
␈↓↓('APPLY*
␈↓␈↓ εK {ON⎇VAR]
[LAMBDA (FNNAME VAR)
␈↓ εK NIL)
(COND
␈↓ εK (COND
((OR (NLISTP FNNAME)
␈↓ εK [(NOT TEM1)
(EQ (CAR FNNAME)
␈↓ εK (COND
(QUOTE LAMBDA)))
␈↓ εK ({OLD⎇ (GO DOPROG]
(LIST FNNAME VAR))
␈↓ εK [(OR {OLD⎇ (NEQ {FINALLY⎇EXPR T))
(T (SUBST VAR (QUOTE @)
␈↓ εK (MAKESUBST0 I.V. TEM1)
FNNAME])
␈↓ εK
␈↓ εK (* OLD on means that I.V. is going to be used later
␈↓↓('HEADPLOOP
␈↓␈↓ εK on. Thus, we set up to substitute TEM1 for I.V.
[LAMBDA (VAR HEADLIST TAILVAR CANNILFLG AFTEREXP)
␈↓ εK later, and return I.V. now)
('PROG
␈↓ εK
NIL
␈↓ εK
(LIST ('SETQ TAILVAR VAR)
␈↓ εK (RETURN (COND
('SETQ (SETQ VAR (BOUNDVAR))
␈↓ εK ((NEQ {FINALLY⎇EXPR T)
HEADLIST)
␈↓ εK {FINALLY⎇EXPR)
(QUOTE $$LP)
␈↓ εK (T I.V.]
(LIST (QUOTE COND)
␈↓ εK (T (GO RET)))
[LIST (LIST (QUOTE NLISTP)
␈↓ εK [SETQ TEM1 (LIST (QUOTE SOME)
VAR)
␈↓ εK {ON⎇VAR
(COND
␈↓ εK (LIST (QUOTE FUNCTION)
[(EQ AFTEREXP T)
␈↓ εK (LIST (QUOTE LAMBDA)
('OR (LIST ('NULL VAR)
␈↓ εK (LIST (GENSYML)
('EQ VAR TAILVAR]
␈↓ εK I.V.)
((NOT CANNILFLG)
␈↓ εK {UNTIL⎇EXPR]
('AND ('NULL VAR)
␈↓ εK RET [RETURN (COND
AFTEREXP))
␈↓ εK ((EQ {FINALLY⎇EXPR T)
(T ('AND ('OR (LIST ('NULL VAR)
␈↓ εK TEM1)
('EQ VAR TAILVAR)))
␈↓ εK (T (* Can use SUBST
AFTEREXP]
␈↓ εK directly, since I.V.
(LIST ('AND ('LISTP TAILVAR)
␈↓ εK occurs nowhere else)
(SUBST TEM1 I.V. {FINALLY⎇EXPR]
␈↓ εK ((& -- $ ! %. T NIL)
DOPROG
␈↓ εK T)
(RETURN
␈↓ εK [←(COND
(CONS (QUOTE PROG)
␈↓ εK ((NEQ BACKPAT (QUOTE VAR))
(APPEND [COND
␈↓ εK (PATPARSEXPR (CDR PAT))
({OLD⎇ (LIST NIL ('SETQ (BINDVAR I.V.)
␈↓ εK (PATPARSE1 (CDDR PAT))
{ON⎇VAR)))
␈↓ εK (RETURN PAT]
(T (LIST (LIST (LIST I.V. {ON⎇VAR]
␈↓ εK (@ (PATPARSEXPR (CDR PAT))
(LIST (QUOTE $$LP)
␈↓ εK (PATPARSE1 (CDDR PAT))
(LIST (QUOTE COND)
␈↓ εK (RETURN PAT))
(LIST {UNTIL⎇EXPR {FINALLY⎇EXPR)
␈↓ εK ((# } *ANY* *EVERY* ≠ ≠≠)
(LIST (LIST (QUOTE NLISTP)
␈↓ εK (PATERR (CONCAT (CAR PAT)
I.V.)
␈↓ εK " not implemented")))
(QUOTE NIL))
␈↓ εK (COND
(LIST T ('SETQ I.V. ('CDR I.V.))
␈↓ εK ((PATPARSEAT PAT (STRPOSL PATCHARRAY
(LIST (QUOTE GO)
␈↓ εK (CAR PAT)
(QUOTE $$LP])
␈↓ εK 1)
␈↓ εK PATCHARS)
␈↓↓('PROGN
␈↓␈↓ εK (* Otherwise, try to
[LAMBDA (LISTOFEXPRESSION)
␈↓ εK PATPARSEAT (CAR PAT))
(COND
␈↓ εK (GO RETRY))
((CDR LISTOFEXPRESSION)
␈↓ εK (T (* Must have a variable
(CONS (QUOTE PROGN)
␈↓ εK here!)
LISTOFEXPRESSION))
␈↓ εK (SETQQ LASTTYPE VAR]
(T (CAR LISTOFEXPRESSION])
␈↓ εK [(NLISTP (CAR PAT))
␈↓ εK (OR (STRINGP (CAR PAT))
␈↓↓('LISTP
␈↓␈↓ εK (NUMBERP (CAR PAT))
[LAMBDA (X)
␈↓ εK (PATERR (CONCAT "Pattern item not atom or list: "
(LIST (QUOTE LISTP)
␈↓ εK (CAR PAT]
X])
␈↓ εK (T (* Otherwise, there is a
)
␈↓ εK subpattern)
␈↓ εK (PATPARSE1 (CAR PAT))
␈↓↓(* PATTERN PARSER)
␈↓␈↓ εK (FRPLACA PAT (MAKESUBPAT (CAR PAT]
␈↓ εK [AND (CDR PAT)
␈↓↓(DEFINEQ
␈↓␈↓ εK (NLISTP (CDR PAT))
␈↓ εK (FRPLACD PAT (LIST (QUOTE %.)
␈↓↓(PATPARSE
␈↓␈↓ εK (CDR PAT]
[LAMBDA (PAT)
␈↓ εK (PATPARSE1 (CDR PAT)
[SETQ PAT (PATPARSE1 (COND
␈↓ εK (OR LASTTYPE (CAR PAT)))
((NLISTP PAT)
␈↓ εK REPARSE
(LIST (QUOTE !)
␈↓ εK (COND
PAT))
␈↓ εK [(EQ (CADR PAT)
(T (COPY PAT]
␈↓ εK (QUOTE ←))
[AND (LITATOM (CAR PAT))
␈↓ εK
[NOT (FMEMB (CAR PAT)
␈↓ εK (* CASES FOR "←" -
(QUOTE (& -- NIL T $]
␈↓ εK (1) pat←expr ---> (-> expr . pat) -
(PATERR (CONCAT "A pattern cannot begin with a " (CAR PAT]
␈↓ εK (2) var←pat ----> (← var . pat) -
PAT])
␈↓ εK (3) !var←pat ---> (← var ! SUBPAT . restofpattern) -
␈↓ εK (4) !←expr -----> (-> expr ! SUBPAT . restofpattern))
␈↓↓(PATPARSE1
␈↓␈↓ εK
[LAMBDA (PAT BACKPAT)
␈↓ εK
␈↓ εK (COND
(* Smashes PAT with it's parsing;
␈↓ εK ((FMEMB (CAR PAT)
BACKPAT is the previous pattern back -
␈↓ εK (QUOTE (! %.))) (* !←expr)
If it was VAR or !, leave it alone -
␈↓ εK [FRPLACA
If it was a pattern, then don't PATPARSE the next
␈↓ εK PAT
thing, since it's an expression)
␈↓ εK (CONS (COND
␈↓ εK ((OR (NULL POSTPONEFLG)
␈↓ εK (EQ POSTPONEFLG (QUOTE ->)))
(PROG (LASTTYPE TEM)
␈↓ εK (QUOTE →))
(COND
␈↓ εK (T (QUOTE ->)))
((NULL PAT)
␈↓ εK (CONS (CADDR PAT)
(RETURN)))
␈↓ εK (COND
RETRY
␈↓ εK [(OR (CDDDDR PAT)
[COND
␈↓ εK (ELT? (CADDDR PAT)))
[(LITATOM (CAR PAT))
␈↓ εK (MAKE!PAT (MAKESUBPAT (CDDDR PAT]
(SELECTQ (CAR PAT)
␈↓ εK (T (CADDDR PAT]
((= == $PACKED$)
␈↓ εK (FRPLACD PAT NIL))
(PATPARSEXPR (CDR PAT))
␈↓ εK [(EQ LASTTYPE (QUOTE VAR)) (* var←pat or !var←pat
(BI12 PAT))
␈↓ εK to ((← var . pat) ...))
('(BI12 PAT))
␈↓ εK (COND
($$ (FRPLACA PAT (QUOTE --)))
␈↓ εK ((CDDR PAT)
($1 (FRPLACA PAT (QUOTE &)))
␈↓ εK [FRPLACA PAT
[* (FRPLACA PAT (CONS (QUOTE *)
␈↓ εK (CONS (COND
(QUOTE &]
␈↓ εK ((AND POSTPONEFLG
(NEQ POSTPONEFLG
␈↓ εK LP (COND
(QUOTE ->)))
␈↓ εK ((NULL CHRS)
(QUOTE <-))
␈↓ εK (RETURN))
(T (QUOTE ←)))
␈↓ εK ((NOT (SETQ TEM (STRPOS (CAR CHRS)
(CONS (CAR PAT)
␈↓ εK (CAR PAT)
(CADDR PAT]
␈↓ εK POS NIL T T)))
(FRPLACD PAT (CDDDR PAT)))
␈↓ εK (SETQ CHRS (CDR CHRS))
(T (PATERR "nothing after a '←' in a pattern"]
␈↓ εK (GO LP)))
(T (* pat←expr)
␈↓ εK
(SETQ TEM (CAR PAT))
␈↓ εK (* Found one -
(FRPLACA PAT (CDR PAT))
␈↓ εK Use this rather than getting pos, since some of
(FRPLACD PAT (CDDDR PAT))
␈↓ εK PATCHARS are more than one char)
(FRPLACD (CDAR PAT)
␈↓ εK
TEM)
␈↓ εK
(FRPLACA (CAR PAT)
␈↓ εK (COND
(COND
␈↓ εK [[NOT (IGREATERP TEM (NCHARS (CAR PAT]
(POSTPONEFLG (QUOTE ->))
␈↓ εK (FRPLACD PAT (CONS (MKATOM (SUBSTRING (CAR PAT)
(T (QUOTE →]
␈↓ εK TEM))
[(FMEMB (CAR PAT)
␈↓ εK (CDR PAT]
(QUOTE (! %.)))
␈↓ εK (T (SETQ TEM NIL)))
(COND
␈↓ εK [SETQ TEM (COND
([AND (EQ (CAR PAT)
␈↓ εK ([AND TEM (EQ (CAR CHRS)
(QUOTE !))
␈↓ εK (QUOTE $))
(FMEMB (CAADR PAT)
␈↓ εK (NOT (FMEMB (NTHCHAR (CAR PAT)
(QUOTE (<- ←]
␈↓ εK TEM)
␈↓ εK (QUOTE (← @]
(* Got (! (← var . pe) ...) from !VAR←PE change it
␈↓ εK (QUOTE $PACKED$))
to (← var ! subpat pe . ...) unless ...
␈↓ εK (T (CAR CHRS]
is NIL and pe is not ELT , in which case, just
␈↓ εK (COND
((← VAR . pe)))
␈↓ εK [(NEQ POS 1)
␈↓ εK (FRPLACD PAT (CONS TEM (CDR PAT)))
␈↓ εK (FRPLACA PAT (MKATOM (SUBSTRING (CAR PAT)
[FRPLACA
␈↓ εK 1
PAT
␈↓ εK (SUB1 POS]
(COND
␈↓ εK (T (FRPLACA PAT TEM)))
([AND (NULL (CDDR PAT))
␈↓ εK (RETURN T])
(NOT (ELT? (CDDR (CADR PAT]
␈↓ εK
(CADR PAT))
␈↓ εK␈↓↓(PATPARSEXPR
␈↓
(T
␈↓ εK [LAMBDA (PAT) (* Look for ←'s in
(CONS
␈↓ εK (CAR PAT))
(CAADR PAT)
␈↓ εK (AND (LITATOM (CAR PAT))
(CONS
␈↓ εK (PATPARSEAT PAT (STRPOSL (QUOTE (@ ←))
(CADR (CADR PAT))
␈↓ εK (CAR PAT)
(MAKE!PAT
␈↓ εK 1)
(MAKESUBPAT (CONS (CDDR (CADR PAT))
␈↓ εK (QUOTE (@ ←])
(CDDR PAT]
␈↓ εK
(FRPLACD PAT NIL))
␈↓ εK␈↓↓(BI12
␈↓
(T (FRPLACA PAT (MAKE!PAT (CADR PAT)))
␈↓ εK [LAMBDA (PAT) (* This changes
(FRPLACD PAT (CDDR PAT]
␈↓ εK (A B ...) to
[(EQ LASTTYPE (QUOTE VAR)) (* var not followed by
␈↓ εK ((A . B) ...))
←... it's a VARDEFAULT)
␈↓ εK (COND
(FRPLACA PAT (MAKEDEFAULT (CAR PAT]
␈↓ εK ((OR (NLISTP PAT)
((EQ (CADR PAT)
␈↓ εK (NLISTP (CDR PAT)))
(QUOTE @))
␈↓ εK (HELP "error in pattern match, at BI12" PAT)))
[FRPLACA PAT (CONS (QUOTE @)
␈↓ εK (PROG ((TEM (CDR PAT)))
(CONS (CADDR PAT)
␈↓ εK (FRPLACD PAT (CDDR PAT))
(CAR PAT]
␈↓ εK (FRPLACD TEM (CAR TEM))
(FRPLACD PAT (CDDDR PAT)))
␈↓ εK (FRPLACA TEM (CAR PAT))
(T (RETURN PAT)))
␈↓ εK (FRPLACA PAT TEM])
(SETQ LASTTYPE NIL)
␈↓ εK
(GO REPARSE])
␈↓ εK␈↓↓(MAKEDEFAULT
␈↓
␈↓ εK [LAMBDA (PATELT LOCALVARDEFAULT)
␈↓↓(PATPARSEAT
␈↓␈↓ εK
[LAMBDA (PAT POS CHRS)
␈↓ εK (* Turns PATELT (which is a LITATOM) into the
␈↓ εK "DEFAULT" pattern -
(* Breaks apart (CAR PAT) if possible, replaces the
␈↓ εK I.e. PATELT couldn't be parsed as a pattern -
parsing into the beginning of PAT ;
␈↓ εK It is assumed that the default for an atom is an
otherwise return NIL if can't -
␈↓ εK element pattern)
POS is the result from STRPOSL)
␈↓ εK
␈↓ εK
␈↓ εK (OR (AND (LITATOM PATELT)
(PROG (TEM)
␈↓ εK (NEQ PATELT T)
(COND
␈↓ εK PATELT)
((NULL POS)
␈↓ εK (HELP "error in pattern matcher at MAKEDEFAULT" PATELT))
(RETURN)))
␈↓ εK (SELECTQ (OR LOCALVARDEFAULT VARDEFAULT)
[(← SETQ SET)
␈↓ εK
(CONS (COND
␈↓ εK␈↓↓(* MISC)
␈↓
(POSTPONEFLG (QUOTE <-))
␈↓ εK
(T (QUOTE ←)))
␈↓ εK␈↓↓(DEFINEQ
␈↓
(CONS PATELT (QUOTE $1]
␈↓ εK
((QUOTE ')
␈↓ εK␈↓↓(PATERR
␈↓
(CONS (QUOTE ')
␈↓ εK [LAMBDA (MSG)
PATELT))
␈↓ εK (ERROR (CONCAT (OR MSG "bad pattern")
((= EQUAL)
␈↓ εK " in:")
(VARCHECK PATELT)
␈↓ εK TOPPAT])
(CONS (QUOTE =)
␈↓ εK
PATELT))
␈↓ εK␈↓↓(PATWARN
␈↓
((== EQ)
␈↓ εK [LAMBDA (MSG)
(VARCHECK PATELT)
␈↓ εK (LISPXPRIN1 MSG T)
(CONS (QUOTE ==)
␈↓ εK (LISPXPRIN1 " in " T)
PATELT))
␈↓ εK (LISPXPRINT TOPPAT T])
[(@ APPLY*)
␈↓ εK
(FNCHECK PATELT)
␈↓ εK␈↓↓(CLISPLOOKUP
␈↓
(CONS (QUOTE @)
␈↓ εK [LAMBDA (FN VAR1 VAR2 LISPFN)
(CONS PATELT (QUOTE &]
␈↓ εK
(COND
␈↓ εK (* In most cases, it is not necessary to do a full
((SETQ LOCALVARDEFAULT (FNCHECK PATELT T T T))
␈↓ εK lookup. This is q uick an dirty check inside of the
(MAKEDEFAULT LOCALVARDEFAULT (QUOTE @)))
␈↓ εK block to avoid calling CLISPLOOKUP0 It will work
((SETQ LOCALVARDEFAULT (VARCHECK PATELT T T T))
␈↓ εK whenever there are no declarations.
(MAKEDEFAULT LOCALVARDEFAULT (QUOTE =)))
␈↓ εK Only difference between this and CLISPIFYLOOKUP is
(T (MAKEDEFAULT PATELT (QUOTE ←])
␈↓ εK that is that we already have performed
␈↓ εK (GETP FN 'LISPFN))
␈↓↓(MAKE!PAT
␈↓␈↓ εK
[LAMBDA (PATELT)
␈↓ εK
(OR (COND
␈↓ εK (PROG (CLASS TEM)
((NLISTP PATELT)
␈↓ εK (RETURN (COND
(SELECTQ PATELT
␈↓ εK ([OR (AND (SETQ CLASS (GETP FN (QUOTE CLISPCLASS)))
(& (QUOTE --))
␈↓ εK (EQ (CAR (SETQ TEM (CADDR EXPR)))
(($ --)
␈↓ εK (QUOTE *))
(QUOTE $))
␈↓ εK (EQ (CADR TEM)
NIL))
␈↓ εK (QUOTE DECLARATIONS:))
(T (SELECTQ (CAR PATELT)
␈↓ εK (SETQ TEM (CDDDR TEM)))
(! (PATERR "Two !'s in a row"))
␈↓ εK (AND (EQ (CAR TEM)
((← <- → -> @)
␈↓ εK (QUOTE CLISP:))
(FRPLACD (CDR PATELT)
␈↓ εK (SETQ TEM (CLISPDEC0 TEM FAULTFN]
(MAKE!PAT (CDDR PATELT)))
␈↓ εK (* must do full lookup.)
PATELT)
␈↓ εK (CLISPLOOKUP0 FN VAR1 VAR2 TEM CLASS))
[* (FRPLACD PATELT (MAKE!PAT (CDR PATELT]
␈↓ εK (T (OR LISPFN FN])
(SUBPAT (AND (NULL (CDDR PATELT))
␈↓ εK
(NOT (ELT? (CADR PATELT)))
␈↓ εK␈↓↓(VARCHECK
␈↓
(CADR PATELT)))
␈↓ εK [LAMBDA (VAR NOMESSFLG SPELLFLG PROPFLG)
($PACKED$ PATELT)
␈↓ εK
NIL)))
␈↓ εK (* Checks if VAR is really a variable -
(CONS (QUOTE !)
␈↓ εK Used by MAKEDEFAULT to avoid bad parsings)
PATELT])
␈↓ εK
␈↓ εK
␈↓↓(MAKESUBPAT
␈↓␈↓ εK (OR (AND (LITATOM VAR)
[LAMBDA (PATLST)
␈↓ εK (OR (NEQ (CAR VAR)
(COND
␈↓ εK (QUOTE NOBIND))
((NULL PATLST)
␈↓ εK (NLSETQ (EVQ VAR)))
NIL)
␈↓ εK VAR)
([OR (EQUAL PATLST (QUOTE (--)))
␈↓ εK (COND
(EQUAL PATLST (QUOTE ($]
␈↓ εK (NOMESSFLG NIL)
(QUOTE &))
␈↓ εK (T (ERROR VAR "NOT A VARIABLE" T])
(T (CONS (QUOTE SUBPAT)
␈↓ εK
PATLST])
␈↓ εK␈↓↓(TRUE
␈↓
)
␈↓ εK [LAMBDA NIL T])
␈↓ εK)
␈↓↓(* FUNCTIONS, CALLS TO WHICH ARE GENERATED)
␈↓␈↓ εK (RPAQQ VARDEFAULT QUOTE)
␈↓ εK (RPAQQ MAXCDDDDRS 5)
␈↓↓(DEFINEQ
␈↓␈↓ εK (RPAQQ POSTPONEFLG T)
␈↓ εK (RPAQQ PATCHECKLENGTH T)
␈↓↓(EQLENGTH
␈↓␈↓ εK (RPAQQ POSTPONEFLG T)
[LAMBDA (X N)
␈↓ εK (RPAQQ PATCAREVALUE T)
(COND
␈↓ εK (RPAQQ CRLIST ((CAR CAAR CDAR CAR NIL)
((ZEROP N)
␈↓ εK (CDR CADR CDDR CDR NIL)
(NLISTP X))
␈↓ εK (CDDDDR NIL NIL CDR CDDDR)
(T (AND (SETQ X (NTH X N))
␈↓ εK (CADDDR NIL NIL CAR CDDDR)
(NLISTP (CDR X])
␈↓ εK (CDDDR CADDDR CDDDDR CDR CDDR)
)
␈↓ εK (CDADDR NIL NIL CDR CADDR)
(CAADDR NIL NIL CAR CADDR)
(CADDR CAADDR CDADDR CAR CDDR)
(CDDR CADDR CDDDR CDR CDR)
(CDDADR NIL NIL CDR CDADR)
(CADADR NIL NIL CAR CDADR)
(CDADR CADADR CDDADR CDR CADR)
(CDAADR NIL NIL CDR CAADR)
(CAAADR NIL NIL CAR CAADR)
(CAADR CAAADR CDAADR CAR CADR)
(CADR CAADR CDADR CAR CDR)
(CDDDAR NIL NIL CDR CDDAR)
(CADDAR NIL NIL CAR CDDAR)
(CDDAR CADDAR CDDDAR CDR CDAR)
(CDADAR NIL NIL CDR CADAR)
(CAADAR NIL NIL CAR CADAR)
(CADAR CAADAR CDADAR CAR CDAR)
(CDAR CADAR CDDAR CDR CAR)
(CDDAAR NIL NIL CDR CDAAR)
(CADAAR NIL NIL CAR CDAAR)
(CDAAR CADAAR CDDAAR CDR CAAR)
(CDAAAR NIL NIL CDR CAAAR)
(CAAAAR NIL NIL CAR CAAAR)
(CAAAR CAAAAR CDAAAR CAR CAAR)
(CAAR CAAAR CDAAR CAR CAR)))
(RPAQQ PATCHARS
(' ← & $$ $ -- @ ! * == =))
␈↓↓(DEFLIST(QUOTE(
␈↓
[EVERY (X (CMAP X (QUOTE (CAR MACROX))
(QUOTE (EVERYLP (COND ((NLISTP MACROX)
(RETURN T))
((NOT MAPF)
(RETURN NIL)))
(SETQ MACROX MAPF2)
(GO EVERYLP]
))(QUOTE MACRO))
[ADDTOVAR PRETTYMACROS (* X (E (TERPRI)
(PRINT (QUOTE (* . X)))
(TERPRI]
(SETQ PATCHARRAY (MAKEBITTABLE PATCHARS))
␈↓↓(DECLARE
␈↓
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHWM 'MATCHTOP 'MATCHEXP 'MATCHELT
'MATCHSUBPAT MAKE'SETQ MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY* MAKE'RETURN MAKE*GLITCH
SKIP$I SKIP$ANY PATLEN $? ELT? ARB? NULLPAT? CANMATCHNIL
CANMATCHNILLIST REPLACEIN REPLACED EASYTORECOMPUTE
FULLEXPANSION GENSYML MAKESUBST0 MAKESUBSTLIST MAKESUBSTLIST1
FORMEXPAND POSTPONEDREPLACE POSTPONEDSETQ POSTPONE SUBSTVAR
BOUNDVAR BINDVAR SELFQUOTEABLE FINDIN0 FINDIN1 DOWATCH UNCROP
'NLEFT 'NOT 'NULL 'NOT1 'NOTLESSPLENGTH 'NTH 'OR 'PLUS
'REPLACE 'SETQ 'AND 'AND2 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LAST 'RETURN 'APPLY* 'HEADPLOOP 'LDIFF 'PROG 'FOR 'PROGN
'LISTP PATPARSE PATPARSE1 PATPARSEAT PATPARSEXPR BI12
MAKEDEFAULT MAKE!PAT MAKESUBPAT PATERR PATWARN CLISPLOOKUP
VARCHECK TRUE (ENTRIES MAKEMATCH)
(GLOBALVARS PATCHARRAY PATCHARS POSTPONEFLG VARDEFAULT CRLIST
PATCHECKLENGTH MAXCDDDDRS)
(LOCALFREEVARS WATCHPOSTPONELST SUBLIST TOPPAT INASOME
CHECKINGLENGTH WMLST LASTEFFECTCANBENIL
POSTPONEDEFFECTS MUSTRETURN BINDINGS
GENSYMVARLIST SKIPEDLEN ZLENFLG SUBPRS)
(SPECVARS STARREPLACED)
(BLKAPPLYFNS TRUE MAKE'RETURN MAKE*GLITCH MAKE'SETQ
MAKEPOSTPONEDSETQ MAKE'REPLACE
MAKEPOSTPONEDREPLACE MAKE'APPLY* 'MATCHWM))
(BLOCK: NIL EQLENGTH (LINKFNS . T))
)STOP